home *** CD-ROM | disk | FTP | other *** search
/ PC World Komputer 2010 April / PCWorld0410.iso / hity wydania / Ubuntu 9.10 PL / karmelkowy-koliberek-desktop-9.10-i386-PL.iso / casper / filesystem.squashfs / usr / share / popularity-contest / popcon-upload < prev   
Text File  |  2009-06-16  |  3KB  |  116 lines
  1. #!/usr/bin/perl -w
  2. # Written by Bill Allombert for the Debian popularity-contest project.
  3. # This file is placed in the public domain.
  4.  
  5. use strict;
  6. use IO::Socket;
  7.  
  8. my %opts;
  9.  
  10. # Not using Getopt::Std to avoid perl-modules dependency
  11. while($#ARGV >= 0 && ($_ = $ARGV[0]) =~ /^-/) {
  12.         shift @ARGV;
  13.         if (/^-C$/) { $opts{'C'} = 1; next }
  14.         if (/^-d$/) { $opts{'d'} = 1; next }
  15.         if (/^-u$/) { $opts{'u'} = shift; next }
  16.         if (/^-f$/) { $opts{'f'} = shift; next }
  17.         &usage("unknown option");
  18.     exit 1;
  19. }
  20.  
  21. sub usage {
  22.     print "popcon-upload: error: @_\n" if ($#_ >= 0);
  23.     print <<"EOF";
  24. Usage: $0 [-Cd] [-u <url>] [-f <file>]
  25.   -C        send submissions in clear text, and not compressed
  26.   -d        enable debugging
  27.   -u <url>  submit to the given URL (default popcon.debian.org)
  28.   -f <file> read popcon report from file (default stdin)
  29. EOF
  30. }
  31.  
  32. my $compressed = 1; # Submit reports in a compressed form?
  33.  
  34. my ($submiturl)  = $opts{'u'} || "http://popcon.debian.org/cgi-bin/popcon.cgi";
  35. my ($file)  = $opts{'f'} || "-";
  36. $compressed = 0 if ($opts{'C'});
  37.  
  38. my ($host) = $submiturl =~ m%http://([^/]+)%;
  39.  
  40. print "Unable to parse url\n" if ($opts{'d'} && ! $host);
  41.  
  42. # Configure the proxy:
  43. my ($http_proxy,$proxy,$port,$remote);
  44.  
  45. $http_proxy=$ENV{'http_proxy'};
  46. if (defined($http_proxy))
  47. {
  48.   $http_proxy =~ m{http://([^:]*)(?::([0-9]+))?} 
  49.         or die ("unrecognized http_proxy");
  50.   $proxy=$1; $port=$2;
  51. }
  52.   
  53. $proxy=$host unless (defined($proxy));
  54. $port=80 unless (defined($port));
  55.  
  56. # Compress the report:
  57. my ($str,$len);
  58. my $encoding;
  59. if ($compressed) {
  60.     open FILE, "gzip -c $file |" or die "gzip -c $file";
  61.     $encoding = "x-gzip";
  62. } else {
  63.     open FILE, "< $file" or die "reading from '$file'";
  64.     $encoding = "identity";
  65. }
  66. $str .= $_ while(<FILE>); 
  67. close(FILE);
  68. $len = length($str);
  69.  
  70. # 30 second timeout on http connections
  71. $SIG{ALRM} = sub { die "timeout in popcon-upload\n" };
  72. alarm(30);
  73.  
  74. # Connect to server
  75. $remote = IO::Socket::INET->new(Proto => "tcp", PeerAddr => $proxy, 
  76.                                                 PeerPort => $port); 
  77. unless ($remote) { die "cannot connect to $proxy:$port" }
  78.  
  79. my $boundary = "----------ThIs_Is_tHe_bouNdaRY_\$";
  80.  
  81. #Content-Length: $len
  82. # text/plain; charset=utf-8
  83. my $ORS = "\r\n"; # Use DOS line endings to make HTTP happy
  84. my $form;
  85. $form .= "--${boundary}$ORS";
  86. $form .= "Content-Disposition: form-data; name=\"popcondata\"; filename=\"popcon-data\"$ORS";
  87. $form .= "Content-Encoding: $encoding$ORS";
  88. $form .= "Content-Type: application/octet-stream$ORS$ORS";
  89. $form .= "$str$ORS";
  90. $form .= "--${boundary}--$ORS";
  91. $form .= "$ORS";
  92.  
  93. my $formlen = length($form);
  94.  
  95. #Send data
  96. print $remote "POST $submiturl HTTP/1.1\r\n";
  97. print $remote "User-Agent: popcon-upload\r\n";
  98. print $remote "Host: $host\r\n";
  99. print $remote "Content-Type: multipart/form-data; boundary=$boundary\r\n";
  100. print $remote "Content-Length: $formlen\r\n";
  101. print $remote "\r\n";
  102. print $remote "$form";
  103.  
  104. #Get answer
  105. my($answer)="";
  106. while(<$remote>)
  107. {
  108.   $answer.=$_;
  109.   m/Thanks/ and last;
  110. }
  111. close ($remote);
  112. #Check answer
  113. my $status = ($answer =~ m/Thanks/) ? 0 : 1;
  114. print "Failed to upload, answer '$answer'\n" if $status && $opts{'d'};
  115. exit $status;
  116.